home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / fdecl.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1989-04-29  |  3.0 KB  |  94 lines
  1. (in-package 'si)
  2.  
  3. ;; by William F. Schelter
  4.  
  5. ;; Conveniently and economically make operators which declare the type
  6. ;; and result of numerical operations.  For example (def-op f+ fixnum +)
  7. ;; defines a macro f+ which will give optimal code for calling + on
  8. ;; several fixnum args expecting a fixnum result.
  9.  
  10. ;; Details:
  11. ;; Note these will be macros and cannot be `funcalled'.  If you add the
  12. ;; feature :debug, then code to check the types of the arguments and
  13. ;; result will be inserted, and generic operations will be used.  This is
  14. ;; useful for checking that you did not insert the wrong type
  15. ;; declarations.  The code will continue running if *dbreak* is nil,
  16. ;; returning the correct result but printing out the type mismatch, as
  17. ;; well as the actual args given so that you may more easily locate the
  18. ;; bad call in the editor.
  19.  
  20. ;; It is economical, beause all the macros defined are just variations
  21. ;; of one closure, and so code is not duplicated.
  22.  
  23. ;; Sample usage (with :debug in *features*):
  24. ;; The call will generate warning messages if the args or result are bad.
  25.  
  26. ;; (defun foo (x a) (f+ (* 2 x) a))
  27. ;; SYSTEM>(foo 7.0 9)
  28.  
  29. ;; Bad call (F+ (* 2 X) A) types:(LONG-FLOAT FIXNUM)
  30. ;; 23.0
  31.  
  32. ;; Without debug (f+ a b c) becomes
  33. ;; (the fixnum (+ (the fixnum a) (the fixnum
  34. ;;                                      (+ (the fixnum b) (the fixnum c)))))
  35. ;; which is painful to write by hand, but which will give the best code.
  36.  
  37.  
  38. (defmacro def-op (name type op &optional return-type)
  39.         `(setf (macro-function ',name) (make-operation ',type ',op
  40.                                ',return-type)))
  41.  
  42. (defun make-operation (.type .op .return)
  43.   (or .return (setf .return .type))
  44.   #'(lambda (bod env) env
  45.       (sloop for v in (cdr bod)
  46.          when (eq t .type) collect v into body
  47.          else
  48.          collect `(the , .type ,v) into body
  49.          finally (setq body `(, .op ,@ body))
  50.          (return
  51.          (if (eq t .return) body
  52.            `(the , .return ,body))))))
  53.  
  54. #+debug
  55. (progn
  56.   ;; Enable this to insert type error checking code.
  57. (defvar *dbreak* t)
  58. (defun callchk-type (lis old na typ sho return-type &aux result)
  59.   (setq result (apply old lis))
  60.   (or (and (sloop for v in lis
  61.           always (typep v typ))
  62.        (or (null return-type) (typep result return-type)))
  63.       (format t "~%Bad call ~a types:~a" (cons na sho)
  64.           (sloop:sloop for v in lis collect (type-of v)))
  65.       (and *dbreak* (break "hi")))
  66.   result)
  67.  
  68. ;; debug version:     
  69. (defmacro def-op (name type old &optional return-type)
  70.   `(defmacro ,name (&rest l)
  71.      `(callchk-type (list ,@ l) ',',old ',',name ',',type ',l ',',return-type 
  72.              )))
  73. )
  74.  
  75. (def-op f+ fixnum +)
  76. (def-op f* fixnum *)
  77. (def-op f- fixnum -)
  78. (def-op +$ double-float +)
  79. (def-op *$ double-float *)
  80. (def-op -$ double-float -)
  81. (def-op 1-$ double-float 1-)
  82. (def-op 1+$ double-float 1+)
  83. (def-op f1- fixnum 1-)
  84. (def-op f1+ fixnum 1+)
  85. (def-op //$ double-float quot)
  86. (def-op ^ fixnum expt)
  87. (def-op ^$ double-float expt)
  88. (def-op f> fixnum > t)
  89. (def-op f< fixnum <  t)
  90. (def-op f= fixnum = t)
  91. (def-op lsh fixnum ash)
  92. (def-op fixnum-remainder fixnum rem)
  93.  
  94.